Cream of the Crop 21/Cream of the Crop 21 (Terry Blount) (October 1996).iso/program/srcbkvt.zip/20_20_4.ASC

Text File | 1996-07-08 | 6KB | 258 lines

_20/20_
by Al Williams

Listing One
{ Shared memory component -- Williams }
unit shdmem;

interface
uses Windows, Messages, Classes, Controls,SysUtils, DsgnIntf, Forms, Dialogs;

type

TShareMem=class(TComponent)
private
  Ffilename : TFileName;  { File name }
  FDeleteFlag : Bool;     { Delete on close? }
  FFirstUser : Bool;      { First user? }
  FNewFile : Bool;        { New file? }
  fileh : THandle;        { File handle }
  fmap : THandle;         { Handle to map }
  addr : PChar;           { Base address }
  Fcount : Integer;       { Number of strings }
  FSize : Integer;        { Size of each string }
  Mutex : THandle;        { Access Mutex }
  FValid : Bool;          { Good flag }
protected
  { no protected declarations }
public
  constructor Create(obj : TComponent); override;
  destructor Destroy; override;
  procedure Loaded; override;
  procedure UnLock;
  procedure Clear;
  function Rcl(n : integer;var s : String) : Bool;
  function Sto(n : integer; s: String) : Bool;
  function Lock(timeout : integer) : Bool;
  Property FirstUser : Bool read FFirstUser;
  Property NewFile: Bool read FNewFile;
  Property FileHandle : THandle read fileh;
  Property Valid : Bool read FValid;
published
  property Count : Integer read FCount write FCount default 100;
  property Size : Integer read FSize write FSize default 256;
  property Filename : TFileName read FFilename write FFilename;
  Property DeleteFlag : Bool read FDeleteFlag write FDeleteFlag;
end;

procedure Register;

implementation
procedure Register;
begin
  RegisterComponents('Samples', [TShareMem]);
end;

constructor TShareMem.Create(obj : TComponent);
begin
  inherited Create(obj);
{ Default setup }
  FCount:=100;
  FSize:=256;
  Mutex:=0;
  fileh:=-1;
  FDeleteFlag:=False;
end;

destructor TShareMem.Destroy;
begin
{ Clear items }
   if addr <> nil then
     UnmapViewOfFile(addr);
   if fmap <> 0 then
     CloseHandle(fmap);
   if fileh <> -1 then
     CloseHandle(fileh);
   if Mutex <> 0 then
     CloseHandle(Mutex);
   inherited Destroy;
end;

procedure TShareMem.Loaded;
var
  delflag : Integer;
begin
  inherited Loaded;
{ Only load if not designing }
  if not (csDesigning in ComponentState) then
  begin
{ Create OR open file mapping -- if map exists, this
   just opens it }
  FValid:=True;  { Assume good things }
  if (Fdeleteflag) then
    delflag:=FILE_FLAG_DELETE_ON_CLOSE
  else
    delflag:=0;
  if Ffilename <> '' then
    fileh:=CreateFile(PChar(Ffilename),
      GENERIC_READ or GENERIC_WRITE,0, nil,
      OPEN_ALWAYS, FILE_ATTRIBUTE_NORMAL or delflag,0)
  else
    fileh:=THandle(-1);
  if (fileh<>THandle(-1)) and
     (GetLastError=Error_Already_Exists) then
     FNewFile:=False
  else
     FNewFile:=True;
  fmap:=CreateFileMapping(fileh,nil,PAGE_READWRITE,0,
      FCount*FSize,PChar(Name));
  if GetLastError=Error_Already_Exists then
    FFirstUser:=False
  else
    FFirstUser:=True;
  if fileh=THandle(-1) then
    FNewFile:=FFirstUser;
  if (fmap=THandle(0)) then FValid:=False;
  addr:=MapViewOfFile(fmap,FILE_MAP_ALL_ACCESS,0,0,
    FCount*FSize);
{ Create locking mutex }
  Mutex:=CreateMutex(nil,FALSE,PChar(Name+'X'));
  if Mutex=THandle(0) then FValid:=False;
 end;
end;

function TShareMem.Rcl(n : integer;var s : String) : Bool;
var
    ps:PChar;
begin
{ Lock, retrieve, and unlock }
   Lock(INFINITE);
   ps:=PChar(addr+(n*FSize));
   s:=StrPas(ps);
   Unlock;
   result:=True;
end;

function TShareMem.Sto(n : integer; s: String) : Bool;
var
   p: PChar;
begin
{ Lock, store, and unlock }
  Lock(INFINITE);
  p:=PChar(addr+(n*FSize));
  StrPCopy(p,s);
  Unlock;
  result:=True;
end;

 function TShareMem.Lock(timeout : integer) : Bool;
  begin
    result:=WaitForSingleObject(Mutex,timeout)<>0;
  end;

procedure TShareMem.Unlock;
  begin
    ReleaseMutex(Mutex);
  end;

procedure TShareMem.Clear;
begin
  Lock(INFINITE);
  FillChar(addr^,FCount*FSize,0);
  Unlock;
end;

end.

Listing Two
{ Check in form }
unit vckinfrm;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls,
  Forms, Dialogs, StdCtrls, shdmem;

type
  TForm1 = class(TForm)
    Label1: TLabel;
    Name: TEdit;
    Label2: TLabel;
    Company: TEdit;
    Label3: TLabel;
    Visited: TEdit;
    Label4: TLabel;
    Timefield: TEdit;
    Label5: TLabel;
    Key: TEdit;
    CheckIn: TButton;
    Clear: TButton;
    SharedMemory: TShareMem;  { Shared Memory!}
    procedure ClearClick(Sender: TObject);
    procedure CheckInClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private
    function GetNewKey : String;
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

function TForm1.GetNewKey : String;
var
  k : String;
  keynum : Integer;
  code : Integer;
begin
{ Lock shared memory }
  SharedMemory.Lock(INFINITE);
{ Get next key }
  SharedMemory.Rcl(0,k);
{ Convert to number }
  Val(k,keynum,code);
{ Set return value from number (if string is empty
  this ensures a zero return value) }
  result:=IntToStr(keynum);
{ Increment next key value and put back }
  keynum:=keynum+1;
  k:=IntToStr(keynum);
  SharedMemory.Sto(0,k);
  SharedMemory.Unlock;
end;

procedure TForm1.CheckInClick(Sender: TObject);
begin
timefield.Text:=TimeToStr(Time);
key.Text:=GetNewKey;
{ commit to database here }
end;

procedure TForm1.ClearClick(Sender: TObject);
begin
timefield.Text:='';
key.Text:='';
name.Text:='';
company.Text:='';
visited.Text:='';
ActiveControl:=Name;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
if SharedMemory.NewFile then
  { clear memory }
  SharedMemory.Clear;
end;

end.